home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / mac / menu-install.el < prev    next >
Encoding:
Text File  |  1994-05-04  |  13.0 KB  |  401 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993, 1994 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8. ;;; GNU General Public License for more details.
  9. ;;;
  10.  
  11. ;;;
  12. ;;; Default menu initialization
  13. ;;;
  14. ;;; Create the menus.  Menus may already have been inserted by the
  15. ;;; .emacs file, so we have to insert these in front of those.    This
  16. ;;; is why we insert in reverse order, each one in front of all those
  17. ;;; inserted previously.
  18. ;;;
  19.  
  20. ;;;
  21. ;;; This variable can be overridden in .emacs
  22. ;;;
  23. (defvar fixed-width-fonts '("Courier" "Monaco"))
  24.  
  25. (defconst font-name-preference-index 130)
  26. (defconst font-size-preference-index 131)
  27.  
  28. (defvar have-menus nil)
  29. (if (not have-menus)
  30.     (progn
  31.       (setq buffers-menu (NewMenu (get-unique-menu-ID) "Buffers"))
  32.       (InsertMenu buffers-menu t)
  33.       
  34.       (setq font-name-menu-id (get-unique-menu-ID))
  35.       (setq font-name-menu (NewMenu font-name-menu-id ""))
  36.       (mapcar (function (lambda (font-name)
  37.               (AppendMenu font-name-menu font-name 'do-font-name)))
  38.           fixed-width-fonts)
  39.       (InsertMenu font-name-menu -1)
  40.  
  41.       ;;; Check the correct item in the font name menu
  42.       (setq last-font-name-menu-check 1)
  43.       (let ((n (CountMItems font-name-menu))
  44.         (current-font-name-code
  45.          (c:slotref 'GrafPort (console-WindowPtr) 'txFont))
  46.         (s (make-string 256 0))
  47.         (font-name-code (make-string 2 0)))
  48.     (while (> n 0)
  49.       (GetItem font-name-menu n s)
  50.       (GetFNum s font-name-code)
  51.       (if (= (extract-internal font-name-code 0 'short)
  52.          current-font-name-code)
  53.           (progn
  54.         (setq last-font-name-menu-check n)
  55.         (setq n 0))
  56.         (setq n (1- n)))))
  57.       (CheckItem font-name-menu last-font-name-menu-check 1)
  58.       
  59.       (setq font-size-menu-id (get-unique-menu-ID))
  60.       (setq font-size-menu (NewMenu font-size-menu-id ""))
  61.       (AppendMenu font-size-menu "9"  'do-font-size)
  62.       (AppendMenu font-size-menu "10" 'do-font-size)
  63.       (AppendMenu font-size-menu "12" 'do-font-size)
  64.       (AppendMenu font-size-menu "14" 'do-font-size)
  65.       (AppendMenu font-size-menu "18" 'do-font-size)
  66.       (AppendMenu font-size-menu "24" 'do-font-size)
  67.       (AppendMenu font-size-menu "(-" nil)
  68.       (AppendMenu font-size-menu "Other..." 'do-font-size-other)
  69.       (InsertMenu font-size-menu -1)
  70.  
  71.       ;;; Check the correct item in the font size menu
  72.       (setq last-font-size-menu-check 8)
  73.       (let ((n (CountMItems font-size-menu))
  74.         (current-font-size
  75.          (c:slotref 'GrafPort (console-WindowPtr) 'txSize))
  76.         (s (make-string 256 0)))
  77.     (while (> n 0)
  78.       (GetItem font-size-menu n s)
  79.       (if (= (string-to-int (PtoCstr s)) current-font-size)
  80.           (progn
  81.         (setq last-font-size-menu-check n)
  82.         (setq n 0))
  83.         (setq n (1- n)))))
  84.       (CheckItem font-size-menu last-font-size-menu-check 1)
  85.       
  86.       (setq special-menu (NewMenu (get-unique-menu-ID) "Special"))
  87.       (AppendMenu special-menu "Show stdout-stderr" 'special-menu-show-stdout)
  88.       (AppendMenu special-menu "Change Stack Size..." 'do-stacksize)
  89.       (AppendMenu special-menu "Change Modifier Keys..." 'do-modifiers)
  90.       (AppendMenu special-menu "(-" nil)
  91.       (AppendMenu special-menu "Font/\033" nil)
  92.       (AppendMenu special-menu "Font Size/\033" nil)
  93.       (AppendMenu special-menu "Edit Colors..." 'do-edit-colors)
  94.       (SetItemMark special-menu 5 font-name-menu-id)
  95.       (SetItemMark special-menu 6 font-size-menu-id)
  96.       (InsertMenu special-menu t)
  97.       
  98.       (setq edit-menu (NewMenu (get-unique-menu-ID) "Edit"))
  99.       (AppendMenu edit-menu "Undo/Z" 'do-undo)
  100.       (AppendMenu edit-menu "(-" nil)
  101.       (AppendMenu edit-menu "Cut/X" 'do-cut)
  102.       (AppendMenu edit-menu "Copy/C" 'do-copy)
  103.       (AppendMenu edit-menu "Paste/V" 'do-paste)
  104.       (AppendMenu edit-menu "Clear" 'do-clear)
  105.       (InsertMenu edit-menu t)
  106.       
  107.       (setq file-menu (NewMenu (get-unique-menu-ID) "File"))
  108.       (AppendMenu file-menu "New Buffer/N" 'do-new)
  109.       (AppendMenu file-menu "Open File Into Buffer.../O" 'do-open)
  110.       (AppendMenu file-menu "Close Buffer/W" 'do-close)
  111.       (AppendMenu file-menu "(-" nil)
  112.       (AppendMenu file-menu "Save/S" 'do-save)
  113.       (AppendMenu file-menu "Save As..." 'do-save-as)
  114.       (AppendMenu file-menu "Revert Buffer" 'do-revert)
  115.       (AppendMenu file-menu "(-" nil)
  116.       (AppendMenu file-menu "Page Setup..." 'do-page-setup)
  117.       (AppendMenu file-menu "Print Buffer/P" 'do-print-buffer)
  118.       (AppendMenu file-menu "Print File From Disk..." 'do-print-file)
  119.       (AppendMenu file-menu "(-" nil)
  120.       (AppendMenu file-menu "Quit Emacs/Q" 'do-quit)
  121.       (InsertMenu file-menu t)
  122.       
  123.       (setq apple-menu (NewMenu (get-unique-menu-ID) "\024"))
  124.       (AppendMenu apple-menu "About Emacs..." 'do-about)
  125.       (AddResMenu apple-menu "DRVR")
  126.       (InsertMenu apple-menu t)
  127.  
  128.       (DrawMenuBar)
  129.       (setq have-menus t)))
  130.  
  131. ;;; Functions to be called in response to the selection of menu items
  132.  
  133. (defun do-new (menu item)
  134.   (let ((buffer (generate-new-buffer "untitled")))
  135.     (switch-to-buffer buffer)))
  136.  
  137. (defun do-open (menu item)
  138.   (let ((file-name (GetFile)))
  139.     (if file-name
  140.         (find-file file-name))))
  141.  
  142. (defun do-close (menu item)
  143.   (if (and (buffer-file-name)
  144.            (buffer-modified-p))
  145.       (progn
  146.         (ParamText (CtoPstr (buffer-name)) (CtoPstr "closing") 0 0)
  147.         (let ((choice (Alert 138 (function alert-filter))))
  148.           (cond
  149.            ((= choice 1)
  150.             (save-buffer)
  151.             (kill-buffer (current-buffer)))
  152.            ((= choice 2)
  153.             nil)
  154.            ((= choice 3)
  155.             (set-buffer-modified-p nil)
  156.             (kill-buffer (current-buffer))))))
  157.     (kill-buffer (current-buffer))))
  158.  
  159. (defun do-save (menu item)
  160.   (if (buffer-file-name)
  161.       (save-buffer)
  162.     (do-save-as 0 0)))
  163.  
  164. (defun do-revert (menu item)
  165.   (revert-buffer))
  166.  
  167. (defun do-save-as (menu item)
  168.   (let ((file-name (PutFile "Save file as:" (buffer-name))))
  169.     (if file-name
  170.         (write-file file-name))))
  171.  
  172. (defun do-page-setup (menu item)
  173.   (call-process "lpr" nil nil nil "-P"))
  174.  
  175. (defun do-print-buffer (menu item)
  176.   (print-buffer))
  177.  
  178. (defun do-print-file (menu item)
  179.   (let ((file-name (GetFile)))
  180.     (if file-name
  181.         (apply (function call-process)
  182.                (append '("lpr" nil 0 nil "-p") lpr-switches (list file-name))))))
  183.  
  184. (defun friendly-quit-queries ()
  185.   (catch 'cancel
  186.     (mapcar
  187.      (function (lambda (x)
  188.                  (if (and (buffer-file-name x)
  189.                           (buffer-modified-p x))
  190.                      (progn
  191.                        (ParamText (CtoPstr (buffer-name x)) (CtoPstr "quitting") 0 0)
  192.                        (let ((choice (Alert 138 (function alert-filter))))
  193.                          (cond
  194.                           ((= choice 1)
  195.                            (save-buffer x))
  196.                           ((= choice 2)
  197.                            (throw 'cancel nil))
  198.                           ((= choice 3)
  199.                            nil)))))))
  200.      (buffer-list))
  201.     t))
  202.  
  203. (defun do-quit (menu item)
  204.   (if (friendly-quit-queries)
  205.       (kill-emacs t)))
  206.  
  207. (defun apple-undo ()
  208.   (interactive)
  209.   (undo)
  210.   (setq last-command 'undo))
  211.   
  212. (defun apple-cut ()
  213.   (interactive)
  214.   (save-excursion (copy-region-to-clipboard))
  215.   (kill-region (point) (if (mark) (mark) (point))))
  216.  
  217. (defun apple-copy ()
  218.   (interactive)
  219.   (save-excursion (copy-region-to-clipboard))
  220.   (copy-region-as-kill (point) (if (mark) (mark) (point))))
  221.   
  222. (defun apple-paste ()
  223.   (interactive)
  224.   (insert-buffer-substring (save-excursion (make-clipboard-current))))
  225.  
  226. (defun apple-clear ()
  227.   (interactive)
  228.   (delete-region (point) (if (mark) (mark) (point))))
  229.  
  230. (defun do-undo (menu item) (apple-undo))
  231. (defun do-cut (menu item) (apple-cut))
  232. (defun do-copy (menu item) (apple-copy))
  233. (defun do-paste (menu item) (apple-paste))
  234. (defun do-clear (menu item) (apple-clear))
  235.  
  236. (defun do-font-size-internal (item size)
  237.   (if (or (>= size 128) (<= size 0))
  238.       (message "You can't be serious!")
  239.     (let ((h (NewHandle 2)))
  240.       (if (zerop (MemError))
  241.           (progn
  242.             (unwind-protect
  243.                 (progn
  244.                   (HLock h)
  245.                   (encode-internal (deref h) 0 'short font-size))
  246.               (HUnlock h))
  247.             (set-preference "DATA" font-size-preference-index h))))
  248.     (special-menu-font-change -1 font-size)
  249.     (CheckItem font-size-menu last-font-size-menu-check 0)
  250.     (CheckItem font-size-menu item 1)
  251.     (setq last-font-size-menu-check item)))
  252.  
  253. (defun do-font-size-other (menu item)
  254.   (let ((font-size (call-interactively (function (lambda (font-size)
  255.                           (interactive "nPoint size: ")
  256.                           font-size)))))
  257.     (do-font-size-internal item font-size)))
  258.  
  259. (defun do-font-size (menu item)
  260.   (let ((s (make-string 256 0)))
  261.     (GetItem font-size-menu item s)
  262.     (let ((font-size (string-to-int (PtoCstr s))))
  263.       (do-font-size-internal item font-size))))
  264.  
  265. (defun do-font-name (menu item)
  266.   (let ((s (make-string 256 0)))
  267.     (GetItem font-name-menu item s)
  268.     (let ((font-number-string (make-string 2 0)))
  269.       (GetFNum s font-number-string)
  270.       (let ((font-number (extract-internal font-number-string 0 'short)))
  271.         (let ((h (NewHandle 2)))
  272.           (if (zerop (MemError))
  273.               (progn
  274.                 (HLock h)
  275.                 (encode-internal (deref h) 0 'short font-number)
  276.                 (HUnlock h)
  277.                 (set-preference "DATA" font-name-preference-index h))))
  278.         (special-menu-font-change font-number -1))))
  279.   (CheckItem font-name-menu last-font-name-menu-check 0)
  280.   (CheckItem font-name-menu item 1)
  281.   (setq last-font-name-menu-check item))
  282.  
  283. (defun do-menu (menu item)
  284.   (let* ((menu-handle (GetMHandle menu))
  285.      (callback (assoc (cons menu-handle item) mac-menu-callback-list)))
  286.     (cond
  287.      (callback
  288.       (funcall (cdr callback) menu-handle item))
  289.      ((= menu-handle apple-menu)
  290.       (let ((s (make-string 256 0)))
  291.     (GetItem apple-menu item s)
  292.     (OpenDeskAcc s)))
  293.      (t
  294.       nil))))
  295.  
  296. (defun buffer-list-for-buffers-menu ()
  297.   (sort (mapcar (function (lambda (x) (cons x (buffer-name x)))) (buffer-list))
  298.     (function (lambda (x y) (string< (upcase (cdr x)) (upcase (cdr y)))))))
  299.  
  300. (defun classify-buffer-list (buffer-list)
  301.   (if (null buffer-list)
  302.       (list nil nil nil)
  303.     (let ((cdr-result (classify-buffer-list (cdr buffer-list)))
  304.           (first-char (substring (cdr (car buffer-list)) 0 1)))
  305.       (set-buffer (car (car buffer-list)))
  306.       (cond
  307.        ((equal " " first-char)
  308.         cdr-result)
  309.        ((equal major-mode 'dired-mode)
  310.         (list (nth 0 cdr-result)
  311.               (cons (car buffer-list) (nth 1 cdr-result))
  312.               (nth 2 cdr-result)))
  313.        ((and (equal "*" first-char) (not (buffer-file-name (car (car buffer-list)))))
  314.         (list (cons (car buffer-list) (nth 0 cdr-result))
  315.               (nth 1 cdr-result)
  316.               (nth 2 cdr-result)))
  317.        (t
  318.         (list (nth 0 cdr-result)
  319.               (nth 1 cdr-result)
  320.               (cons (car buffer-list) (nth 2 cdr-result))))))))
  321.  
  322. (defun append-buffer-menu (buffer-list i check-modified)
  323.   (if (null buffer-list)
  324.       i
  325.     (let ((buffer (car (car buffer-list)))
  326.       (name (cdr (car buffer-list))))
  327.       (AppendMenu buffers-menu " " 'do-buffers-menu-item)
  328.       (SetItem buffers-menu i name)
  329.       (if (and check-modified (buffer-modified-p buffer))
  330.       (SetItemMark buffers-menu i 215)))
  331.     (append-buffer-menu (cdr buffer-list) (1+ i) check-modified)))
  332.  
  333. (defun fixup-buffers-menu ()
  334.   ;;; Remove the old buffer list.
  335.   (let ((n (CountMItems buffers-menu)))
  336.     (while (> n 0)
  337.       (DelMenuItem buffers-menu 1)
  338.       (setq n (1- n))))
  339.  
  340.   ;;; Remove the old callback functions from the callback list.
  341.   (let ((x mac-menu-callback-list))
  342.     (setq mac-menu-callback-list nil)
  343.     (while x
  344.       (if (not (eq (car (car (car x))) buffers-menu))
  345.       (setq mac-menu-callback-list (cons (car x) mac-menu-callback-list)))
  346.       (setq x (cdr x))))
  347.  
  348.   ;;; Create the new buffer list
  349.   (let* ((old-buffer (current-buffer))
  350.      next-item
  351.      (buffer-list (buffer-list-for-buffers-menu))
  352.      (classified-buffers (classify-buffer-list buffer-list))
  353.      (temp-buffers (nth 0 classified-buffers))
  354.      (dired-buffers (nth 1 classified-buffers))
  355.      (other-buffers (nth 2 classified-buffers)))
  356.     (setq next-item (append-buffer-menu temp-buffers 1 nil))
  357.     (if (and temp-buffers dired-buffers)
  358.     (progn (AppendMenu buffers-menu "(-" nil) (setq next-item (1+ next-item))))
  359.     (setq next-item (append-buffer-menu dired-buffers next-item nil))
  360.     (if (and (or temp-buffers dired-buffers) other-buffers)
  361.     (progn (AppendMenu buffers-menu "(-" nil) (setq next-item (1+ next-item))))
  362.     (append-buffer-menu other-buffers next-item t)
  363.     (set-buffer old-buffer)))
  364.  
  365. (defun do-buffers-menu-item (menu item)
  366.   (let ((s (make-string 256 0)))
  367.     (GetItem buffers-menu item s)
  368.     (switch-to-buffer (PtoCstr s))))
  369.  
  370. (defvar MenuSelect-before-hooks (list (function fixup-buffers-menu)))
  371.  
  372. (defun do-MenuSelect-before-hooks ()
  373.   (mapcar (function funcall) MenuSelect-before-hooks))
  374.  
  375. (defun alert-filter (d e i)
  376.   (let ((what (c:slotref 'EventRecord e 'what)))
  377.     (cond
  378.      ((= what keyDown)
  379.       (let ((c (logand (c:slotref 'EventRecord e 'message) charCodeMask))
  380.             (modifiers (c:slotref 'EventRecord e 'modifiers)))
  381.         (cond
  382.          ((or (= c (string-to-char "\r")) (= c 3))
  383.           (encode-internal i 0 'short 1)
  384.           (blink d 1)
  385.           1)
  386.          ((and (= c (string-to-char ".")) (not (zerop (logand modifiers cmdKey))))
  387.           (encode-internal i 0 'short 2)
  388.           (blink d 2)
  389.           1)
  390.          ((and (= c (string-to-char "d")) (not (zerop (logand modifiers cmdKey))))
  391.           (encode-internal i 0 'short 3)
  392.           (blink d 3)
  393.           1)
  394.          (t
  395.           0))))
  396.      (t
  397.       0))))
  398.  
  399. (defvar menu-install-hooks nil)
  400. (mapcar 'eval menu-install-hooks)
  401.